package Data::Conveyor::App::Test::Stage;

use strict;
use warnings;
use YAML::Active qw/Dump Reload/;
use String::FlexMatch::Test;
use Test::More;
use Data::Dumper;


our $VERSION = '0.02';


use base 'Class::Scaffold::App::Test::YAMLDriven';


$Data::Dumper::Indent = 1;

__PACKAGE__->mk_scalar_accessors(qw(
    ticket ticket_no stage expected_stage_const
));


use constant DEFAULTS => (
    runs => 2,
);


sub expected_stage {
    my $self = shift;
    my $method = $self->expected_stage_const;
    $self->delegate->$method;
}


sub execute_test_def {
    my ($self, $testname) = @_;
    if ($self->should_skip_testname($testname)) {
        $self->SUPER::execute_test_def($testname);
    } else {
        $self->make_ticket($testname);
        $self->SUPER::execute_test_def($testname);
        $self->ticket->delete;
    }
}


sub make_ticket {
    my ($self, $testname) = @_;

    $self->test_def($testname,
        Reload($self->test_def($testname), $self->delegate->YAP_MAKE_TICKET)
    );

    my $ticket = $self->delegate->make_obj('test_ticket')->make_whole_ticket(
        %{$self->test_def($testname)->{make_whole_ticket}}
    );
    $self->gen_tx_item_ref($ticket->payload);
    $ticket->store_full;

    # Set up some accessors so other methods can refer to them.

    $self->ticket_no($ticket->ticket_no);
}


sub gen_tx_item_ref {
    my ($self, $payload) = @_;

    for my $payload_tx ($payload->transactions) {
        my $item_spec = $payload_tx->transaction->payload_item;
        next if ref $item_spec;
        if ($item_spec =~ /^(\w+)\.(\d+)$/) {
            my ($accessor, $index) = ($1, $2-1);
            $payload_tx->transaction->payload_item(eval
                "\$payload->$accessor\->[$index]");
            die $@ if $@;
        }
        unless (ref $payload_tx->transaction->payload_item) {
            throw Error::Hierarchy::Internal::CustomMessage(
                custom_message => sprintf 'No such payload item [%s]',
                    $item_spec,
            );
        }
    }
}


sub make_stage_object {
    my $self = shift;
    $self->stage($self->delegate->make_stage_object($self->expected_stage, @_));
}


# subclasses can do preparatory things here
sub before_stage_hook {}


sub run_test {
    my $self = shift;

    # At this point, set any local configuration the test yaml file might have
    # asked for.

    local %Class::Scaffold::Environment::Configurator::Local::opt = (
        %Class::Scaffold::Environment::Configurator::Local::opt,
        %{ $self->current_test_def->{opt} || {} },
    );

    my $ticket = $self->delegate->make_obj('ticket', 
        ticket_no => $self->ticket_no,
    );
    $ticket->open($self->expected_stage);

    $self->before_stage_hook($ticket);
    $self->stage($self->make_stage_object(ticket => $ticket));

    $self->stage->run;

    $ticket->store if $ticket->rc eq $self->delegate->RC_INTERNAL_ERROR;
    $ticket->close;

    # The ticket that we test our expectations against is a fresh ticket
    # object where we read the ticket we just wrote. Note that we read(), not
    # open() the ticket, because after the stage run, it will still be in
    # an 'active_*' stage, and open() wouldn't find it.

    $self->ticket($self->delegate->make_obj('ticket', 
        ticket_no => $self->ticket_no,
    ));
    $self->ticket->read;

    $self->test_expectations;

    # To prepare for the next run, reset the ticket to the stage start and an
    # ok status and rc, just as you'd do manually when rerunning the ticket in
    # the regsh. Note that this is the same as would happen in the regsh when
    # given the command 'set_stage -g starten_<stagename>'

    for ($self->ticket) {
        $_->stage->new_start($self->expected_stage);
        $_->status($self->delegate->TS_RUNNING);
        $_->rc($self->delegate->RC_OK);
        $_->close_basic;
    }
}


sub test_expectations {
    my $self = shift;
    # give the objects a chance to prepare themselves for comparison
    $self->ticket->comparable;
}


sub plan_ticket_expected_container {
    my ($self, $test, $run) = @_;
    my $plan = 2;     # rc, status

    # The expected exceptions look like this in the YAML files:
    #
    #    exceptions:
    #      person:
    #        -
    #          # expect the following exceptions for the first person
    #          - ref: Registry::Exception::Person::InvalidEmail
    #            handle: ...
    #            email: ...
    #          - ref: Registry::Exception::Person::InvalidName
    #            handle: ...
    #            name ...
    #        -
    #          # expect the following exceptions for the second person
    #          - ref: ...
    #            ...
    #      domains:
    #        -
    #          # expect the following exceptions for the first domain
    #          - ref: ...
    #            ...
    #
    # Usually, we expect two tests per exception per run (one for the
    # exception's type and for for its message). There's a special
    # case that complicates the thing a bit: Some policies actually alter the
    # ticket. For example, if, in a person, we detect an alias name for a
    # country (e.g., 'Oesterreich', which is mapped to the normal name,
    # 'Austria'), the policy actually replaces the country name with the
    # normal name. So the second time around, the country name will be the
    # normal one and no exception is thrown.

    while (my ($object_type, $spec) =
            each %{ $test->{expect}{exceptions} || {} }) {

        for my $payload_item (@$spec) {
            for my $exception (ref $payload_item eq 'ARRAY'
                ? @$payload_item
                : $payload_item) {

                next unless ref($exception) eq 'HASH';
                next if $run > 1 &&
                    $exception->{ref} =~ /Replace(Fax|Phone)No$/;
                $plan += 2;
            }
        }
    }

    $plan;
}


sub plan_ticket_tx {
    my ($self, $test) = @_;
    exists $test->{expect}{tx};
}


sub check_ticket_rc_status {
    my $self = shift;

    is($self->ticket->rc, $self->expect->{rc} || $self->delegate->RC_OK,
        $self->named_test('rc'));

    is($self->ticket->status,
       $self->expect->{status} || $self->delegate->TS_RUNNING,
       $self->named_test('status'));
}


sub check_ticket_tx {
    my $self = shift;
    return unless exists $self->expect->{tx};

    my @tx_status =
        map { $_->transaction->status }
        $self->ticket->payload->transactions;

    # Dump as YAML on failure, so we see the stringified values, not the value
    # objects.

    ok(eq_array_flex(\@tx_status, $self->expect->{tx}),
        $self->named_test('resulting tx status'))
        or print Dump \@tx_status;
}


sub check_ticket_expected_container {
    my $self = shift;

    $self->check_ticket_rc_status($self->ticket);

    for my $object_type ($self->delegate->OT) {
        my $item_index = 0;
        for my $payload_item (
            $self->ticket->payload->get_list_for_object_type($object_type)) {
                $self->compare_exceptions(
                    $object_type,
                    $payload_item,
                    ($self->expect->{exceptions}{$object_type}[$item_index++] || []),
                )
        }
    }

    $self->compare_exceptions(
        'common',
        $self->ticket->payload->common,
        ($self->expect->{exceptions}{common} || []),
    )
}


sub compare_exceptions {
    my ($self, $object_type, $payload_item, $expected_exceptions) = @_;
    my $exception_index = 0;
    return unless ref $expected_exceptions eq 'ARRAY';

    # Impose an order on the exceptions, namely the way they stringify for the
    # benefit of the yaml test files.

    for my $got_exception (sort { "$a" cmp "$b" }
            $payload_item->exception_container->items) {

        unless (exists $expected_exceptions->[$exception_index]) {
            fail(sprintf
                "Unexpected exception on [%s] of type [%s], message [%s]",
                $object_type, ref($got_exception), $got_exception
            );
            print Dumper $got_exception;
            next;
        }

        # Ok, we did expect an exception, so check whether it's the
        # right one.

        my $expected_exception =
            $expected_exceptions->[$exception_index];

        isa_ok($got_exception, $expected_exception->{ref});

        # FIXME
        # hack for Class::Value::Exception::InvalidValue, which has a property
        # called 'ref'. But the test definition of the expected exception also
        # has a 'ref' property to indicate what type of exception we expect.
        # So the test def's 'p_ref' is munged to become the 'ref' of
        # Class::Value::Exception::InvalidValue. Solution: call the exception
        # property something else.
        #
        # Example:
        #
        # exceptions:
        #   person:
        #     -
        #       -
        #         ref: Class::Value::Exception::InvalidValue
        #         p_ref: Registry::NICAT::Value::Person::Handle
        #         value: *HANDLE

        my %expected_properties = %$expected_exception;
        delete $expected_properties{ref};
        $expected_properties{ref} =
            delete $expected_properties{p_ref}
            if $expected_properties{p_ref};

        is_deeply_flex(
            scalar($got_exception->properties_as_hash),
            \%expected_properties,
            'exception properties'
        ) or print Dumper $got_exception;

        # Following the same logic as commented in
        # plan_ticket_expected_container(), eliminate those exceptions
        # from the expected list after the first run that would only
        # occur in the first run, i.e. Replace* exceptions. That way,
        # we won't even see them in the list of expected exceptions in
        # the second and subsequent runs.

        if ($self->run_num == 1 &&
            defined($expected_exception) &&
            $expected_exception->{ref} =~ /Replace(Fax|Phone)No$/) {

            splice @$expected_exceptions, $exception_index, 1;
        }

    } continue {
        $exception_index++;
    }

    # Now we check whether there are further expected exceptions -
    # this would be ones we expected but didn't get.

    while (defined (my $extra = $expected_exceptions->[$exception_index++])) {
        fail(sprintf
            "Didn't see expected exception of type [%s]",
            $extra->{ref},
        );
    }
}


sub is_deep_set {
    my ($self, $got, $expect, $test_name) = @_;

    $got    = [ sort _by_dump @{ $got    || [] } ];
    $expect = [ sort _by_dump @{ $expect || [] } ];

    is_deeply_flex($got, $expect, $test_name) or print
        YAML::Active::Dump($got,    ForceBlock => 0),
        YAML::Active::Dump($expect, ForceBlock => 0);
}


sub _by_dump { YAML::Active::Dump($a) cmp YAML::Active::Dump($b) }


1;


__END__

{% USE p = PodGenerated %}

=head1 NAME

{% p.package %} - stage-based conveyor-belt-like ticket handling system

=head1 SYNOPSIS

    {% p.package %}->new;

=head1 DESCRIPTION

None yet. This is an early release; fully functional, but undocumented. The
next release will have more documentation.

=head1 METHODS

=over 4

{% p.write_methods %}

=back

{% p.write_inheritance %}

{% PROCESS standard_pod %}

=cut

